home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASWIZ20 / MUSIC.PAS < prev    next >
Pascal/Delphi Source File  |  1994-11-04  |  7KB  |  295 lines
  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1994  Thomas G. Hanlin III         |
  4.     |                                                                      |
  5.     +----------------------------------------------------------------------+
  6.  
  7.  
  8.  
  9. Music:
  10.  
  11.    This unit provides a music interpreter that works like BASIC's PLAY
  12.    statement.  Currently, only foreground music is supported.  See the
  13.    PASWIZ.DOC manual for information about the command set.
  14.  
  15. }
  16.  
  17.  
  18.  
  19. UNIT Music;
  20.  
  21.  
  22.  
  23. INTERFACE
  24.  
  25.  
  26.  
  27. PROCEDURE PlayMF (Sounds: String);
  28. PROCEDURE ResetMF;
  29.  
  30.  
  31.  
  32. { --------------------------------------------------------------------------- }
  33.  
  34.  
  35.  
  36. IMPLEMENTATION
  37.  
  38.  
  39.  
  40. USES
  41.    CRT;
  42.  
  43.  
  44.  
  45. {$F+}
  46.  
  47. FUNCTION UpperCase (St: String): String; external;
  48. FUNCTION WVal (St: String): Word; external;
  49.  
  50. {$L UPCASE.OBJ}
  51. {$L WVAL.OBJ}
  52.  
  53.  
  54.  
  55. VAR
  56.    Octave, NoteLen, Tempo, SoundLen, TmpNoteLen: Integer;
  57.    BaseOctave: Array[0..11] of Integer;
  58.    BaseTime: LongInt;
  59.    Nr: Integer;
  60.    Error: Boolean;
  61.    NoteConvert: String;
  62.  
  63.  
  64.  
  65. { grab a number from the music string }
  66. PROCEDURE GetNum (VAR St: String; VAR Nr: Integer; VAR Error: Boolean);
  67. VAR
  68.    Acc: String;
  69. BEGIN
  70.    Acc := '';
  71.    WHILE (Length(St) > 0) AND (Pos(St[1], '0123456789') > 0) DO BEGIN
  72.       Acc := Acc + St[1];
  73.       Delete(St, 1, 1);
  74.    END;
  75.    IF (Length(Acc) = 0) OR (Length(Acc) > 3) THEN
  76.       Error := TRUE
  77.    ELSE BEGIN
  78.       Error := FALSE;
  79.       Nr := WVal(Acc);
  80.    END;
  81. END;
  82.  
  83.  
  84.  
  85. { play a note }
  86. PROCEDURE PlayNote (Freq: Word);
  87. VAR
  88.    Time: Word;
  89. BEGIN
  90.    IF TmpNoteLen = 0 THEN
  91.       TmpNoteLen := NoteLen;
  92.    Time := BaseTime DIV (Tempo * TmpNoteLen);
  93.    IF Freq > 0 THEN
  94.       Sound(1193180 DIV Freq);
  95.    Delay(SoundLen * Time);
  96.    IF Freq > 0 THEN
  97.       NoSound;
  98.    Delay((8 - SoundLen) * Time);
  99.    TmpNoteLen := 0;
  100.    BaseTime := 38000;
  101. END;
  102.  
  103.  
  104.  
  105. { ---- procs to handle music commands ------------------------------------- }
  106.  
  107.  
  108.  
  109. PROCEDURE DoLength (VAR Sounds: String);
  110. BEGIN
  111.    GetNum(Sounds, Nr, Error);
  112.    IF NOT Error AND (Nr > 0) AND (Nr < 65) THEN
  113.       NoteLen := Nr;
  114. END;
  115.  
  116.  
  117.  
  118. PROCEDURE DoMiscCmd (VAR Sounds: String);
  119. BEGIN
  120.    IF Length(Sounds) > 0 THEN BEGIN
  121.       CASE Sounds[1] OF
  122.          'L': SoundLen := 8;    { legato }
  123.          'N': SoundLen := 7;    { normal }
  124.          'S': SoundLen := 6;    { staccato }
  125.          ELSE ;                 { either MF (default) or MB (not supported) }
  126.       END;
  127.       Delete(Sounds, 1, 1);
  128.    END;
  129. END;
  130.  
  131.  
  132.  
  133. PROCEDURE DoNoteLetter (VAR Sounds: String; Ch: Char);
  134. VAR
  135.    SpecialLen, NotePos: Integer;
  136.    DotLen: LongInt;
  137.    NoteInfo: String;
  138. BEGIN
  139.    NotePos := ORD(NoteConvert[ORD(Ch) - 64]) - 65;
  140.    IF Length(Sounds) > 0 THEN BEGIN
  141.       NoteInfo := '';
  142.       Ch := Sounds[1];
  143.       Delete(Sounds, 1, 1);
  144.       IF Ch = '-' THEN BEGIN
  145.          IF (NotePos IN [2, 4, 7, 9, 11]) THEN
  146.             DEC(NotePos);
  147.          IF (Length(Sounds) > 0) AND (Sounds[1] IN ['0'..'9', '.']) THEN BEGIN
  148.             Ch := Sounds[1];
  149.             Delete(Sounds, 1, 1);
  150.          END;
  151.       END ELSE IF ((Ch = '+') OR (Ch = '#')) THEN BEGIN
  152.          IF (NotePos IN [0, 2, 5, 7, 9]) THEN
  153.             INC(NotePos);
  154.          IF (Length(Sounds) > 0) AND (Sounds[1] IN ['0'..'9', '.']) THEN BEGIN
  155.             Ch := Sounds[1];
  156.             Delete(Sounds, 1, 1);
  157.          END;
  158.       END
  159.       ELSE IF NOT(Ch IN ['0'..'9', '.']) THEN
  160.          Sounds := Ch + Sounds;
  161.       IF (Ch IN ['0'..'9', '.']) THEN BEGIN
  162.          NoteInfo := NoteInfo + Ch;
  163.          WHILE (Length(Sounds) > 0) AND (Sounds[1] IN ['0'..'9', '.']) DO BEGIN
  164.             NoteInfo := NoteInfo + Sounds[1];
  165.             Delete(Sounds, 1, 1);
  166.          END;
  167.          IF TmpNoteLen = 0 THEN
  168.             TmpNoteLen := NoteLen;
  169.          DotLen := BaseTime;
  170.          WHILE Pos('.', NoteInfo) > 0 DO BEGIN
  171.             DotLen := DotLen SHR 1;
  172.             BaseTime := BaseTime + DotLen;
  173.             Delete(NoteInfo, Pos('.', NoteInfo), 1);
  174.          END;
  175.          IF (Length(NoteInfo) > 0) AND (Length(NoteInfo) < 3) THEN BEGIN
  176.             SpecialLen := WVal(NoteInfo);
  177.             IF (SpecialLen > 0) AND (SpecialLen < 65) THEN
  178.                TmpNoteLen := SpecialLen;
  179.          END;
  180.       END;
  181.    END;
  182.    PlayNote(BaseOctave[NotePos] SHR Octave);
  183. END;
  184.  
  185.  
  186.  
  187. PROCEDURE DoNoteNumber (VAR Sounds: String);
  188. BEGIN
  189.    GetNum(Sounds, Nr, Error);
  190.    IF NOT Error AND (Nr >= 0) AND (Nr <= 84) THEN
  191.       IF Nr = 0 THEN
  192.          PlayNote(Nr)
  193.       ELSE BEGIN
  194.          DEC(Nr);
  195.          PlayNote(BaseOctave[Nr MOD 12] SHR (Nr DIV 12));
  196.       END;
  197. END;
  198.  
  199.  
  200.  
  201. PROCEDURE DoOctave (VAR Sounds: String);
  202. BEGIN
  203.    GetNum(Sounds, Nr, Error);
  204.    IF NOT Error AND (Nr >= 0) AND (Nr <= 6) THEN
  205.       Octave := Nr;
  206. END;
  207.  
  208.  
  209.  
  210. PROCEDURE DoPause (VAR Sounds: String);
  211. BEGIN
  212.    GetNum(Sounds, Nr, Error);
  213.    IF NOT Error AND (Nr > 0) AND (Nr < 65) THEN BEGIN
  214.       TmpNoteLen := Nr;
  215.       PlayNote(0);
  216.    END;
  217. END;
  218.  
  219.  
  220.  
  221. PROCEDURE DoTempo (VAR Sounds: String);
  222. BEGIN
  223.    GetNum(Sounds, Nr, Error);
  224.    IF NOT Error AND (Nr >= 32) AND (Nr <= 255) THEN
  225.       Tempo := Nr;
  226. END;
  227.  
  228.  
  229.  
  230. { ---- public procs ------------------------------------------------------- }
  231.  
  232.  
  233.  
  234. { play music in the foreground }
  235. PROCEDURE PlayMF (Sounds: String);
  236. VAR
  237.    Posn: Integer;
  238.    Ch: Char;
  239. BEGIN
  240.    REPEAT                                        { remove spaces }
  241.       Posn := Pos(' ', Sounds);
  242.       IF Posn > 0 THEN
  243.          Delete(Sounds, Posn, 1);
  244.    UNTIL Posn = 0;
  245.    Sounds := UpperCase(Sounds);                  { convert to uppercase }
  246.    WHILE (Length(Sounds) > 0) DO BEGIN           { process music commands }
  247.       Ch := Sounds[1];
  248.       Delete(Sounds, 1, 1);
  249.       CASE Ch OF
  250.          '<': IF Octave > 1 THEN Dec(Octave);
  251.          '>': IF Octave < 6 THEN Inc(Octave);
  252.          'A'..'G': DoNoteLetter(Sounds, Ch);
  253.          'L': DoLength(Sounds);
  254.          'M': DoMiscCmd(Sounds);
  255.          'N': DoNoteNumber(Sounds);
  256.          'O': DoOctave(Sounds);
  257.          'P': DoPause(Sounds);
  258.          'T': DoTempo(Sounds);
  259.       END;
  260.    END;
  261. END;
  262.  
  263.  
  264.  
  265. { reset defaults to original values }
  266. PROCEDURE ResetMF;
  267. BEGIN
  268.    TmpNoteLen := 0;
  269.    BaseTime := 38000;
  270.    Octave := 4;
  271.    NoteLen := 4;
  272.    Tempo := 120;
  273.    SoundLen := 7;
  274. END;
  275.  
  276.  
  277.  
  278. { ----------------------- initialization code --------------------------- }
  279. BEGIN
  280.    BaseOctave[0]  := 18357;    { C }
  281.    BaseOctave[1]  := 17292;    { C# or D- }
  282.    BaseOctave[2]  := 16124;    { D }
  283.    BaseOctave[3]  := 15297;    { D# or E- }
  284.    BaseOctave[4]  := 14551;    { E }
  285.    BaseOctave[5]  := 13715;    { F }
  286.    BaseOctave[6]  := 12830;    { F# or G- }
  287.    BaseOctave[7]  := 12175;    { G }
  288.    BaseOctave[8]  := 11473;    { G# }
  289.    BaseOctave[9]  := 10847;    { A }
  290.    BaseOctave[10] := 10286;    { A# or B- }
  291.    BaseOctave[11] := 9623;     { B }
  292.    NoteConvert := 'JLACEFH';
  293.    ResetMF;
  294. END.
  295.